home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Module / Build / Platform / Windows.pm < prev   
Encoding:
Perl POD Document  |  2009-06-26  |  6.6 KB  |  259 lines
  1. package Module::Build::Platform::Windows;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. $VERSION = '0.2808_01';
  6. $VERSION = eval $VERSION;
  7.  
  8. use Config;
  9. use File::Basename;
  10. use File::Spec;
  11. use IO::File;
  12.  
  13. use Module::Build::Base;
  14.  
  15. use vars qw(@ISA);
  16. @ISA = qw(Module::Build::Base);
  17.  
  18.  
  19. sub manpage_separator {
  20.     return '.';
  21. }
  22.  
  23. sub have_forkpipe { 0 }
  24.  
  25. sub _detildefy {
  26.   my ($self, $value) = @_;
  27.   $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
  28.     if $ENV{HOME};
  29.   return $value;
  30. }
  31.  
  32. sub ACTION_realclean {
  33.   my ($self) = @_;
  34.  
  35.   $self->SUPER::ACTION_realclean();
  36.  
  37.   my $basename = basename($0);
  38.   $basename =~ s/(?:\.bat)?$//i;
  39.  
  40.   if ( $basename eq $self->build_script ) {
  41.     if ( $self->build_bat ) {
  42.       my $full_progname = $0;
  43.       $full_progname =~ s/(?:\.bat)?$/.bat/i;
  44.  
  45.       # Vodoo required to have a batch file delete itself without error;
  46.       # Syntax differs between 9x & NT: the later requires a null arg (???)
  47.       require Win32;
  48.       my $null_arg = (Win32::IsWinNT()) ? '""' : '';
  49.       my $cmd = qq(start $null_arg /min "\%comspec\%" /c del "$full_progname");
  50.  
  51.       my $fh = IO::File->new(">> $basename.bat")
  52.         or die "Can't create $basename.bat: $!";
  53.       print $fh $cmd;
  54.       close $fh ;
  55.     } else {
  56.       $self->delete_filetree($self->build_script . '.bat');
  57.     }
  58.   }
  59. }
  60.  
  61. sub make_executable {
  62.   my $self = shift;
  63.  
  64.   $self->SUPER::make_executable(@_);
  65.  
  66.   foreach my $script (@_) {
  67.  
  68.     # Native batch script
  69.     if ( $script =~ /\.(bat|cmd)$/ ) {
  70.       $self->SUPER::make_executable($script);
  71.       next;
  72.  
  73.     # Perl script that needs to be wrapped in a batch script
  74.     } else {
  75.       my %opts = ();
  76.       if ( $script eq $self->build_script ) {
  77.         $opts{ntargs}    = q(-x -S %0 --build_bat %*);
  78.         $opts{otherargs} = q(-x -S "%0" --build_bat %1 %2 %3 %4 %5 %6 %7 %8 %9);
  79.       }
  80.  
  81.       my $out = eval {$self->pl2bat(in => $script, update => 1, %opts)};
  82.       if ( $@ ) {
  83.         $self->log_warn("WARNING: Unable to convert file '$script' to an executable script:\n$@");
  84.       } else {
  85.         $self->SUPER::make_executable($out);
  86.       }
  87.     }
  88.   }
  89. }
  90.  
  91. # This routine was copied almost verbatim from the 'pl2bat' utility
  92. # distributed with perl. It requires too much vodoo with shell quoting
  93. # differences and shortcomings between the various flavors of Windows
  94. # to reliably shell out
  95. sub pl2bat {
  96.   my $self = shift;
  97.   my %opts = @_;
  98.  
  99.   # NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
  100.   $opts{ntargs}    = '-x -S %0 %*' unless exists $opts{ntargs};
  101.   $opts{otherargs} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $opts{otherargs};
  102.  
  103.   $opts{stripsuffix} = '/\\.plx?/' unless exists $opts{stripsuffix};
  104.   $opts{stripsuffix} = ($opts{stripsuffix} =~ m{^/([^/]*[^/\$]|)\$?/?$} ? $1 : "\Q$opts{stripsuffix}\E");
  105.  
  106.   unless (exists $opts{out}) {
  107.     $opts{out} = $opts{in};
  108.     $opts{out} =~ s/$opts{stripsuffix}$//oi;
  109.     $opts{out} .= '.bat' unless $opts{in} =~ /\.bat$/i or $opts{in} =~ /^-$/;
  110.   }
  111.  
  112.   my $head = <<EOT;
  113.     \@rem = '--*-Perl-*--
  114.     \@echo off
  115.     if "%OS%" == "Windows_NT" goto WinNT
  116.     perl $opts{otherargs}
  117.     goto endofperl
  118.     :WinNT
  119.     perl $opts{ntargs}
  120.     if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
  121.     if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  122.     if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  123.     goto endofperl
  124.     \@rem ';
  125. EOT
  126.  
  127.   $head =~ s/^\s+//gm;
  128.   my $headlines = 2 + ($head =~ tr/\n/\n/);
  129.   my $tail = "\n__END__\n:endofperl\n";
  130.  
  131.   my $linedone  = 0;
  132.   my $taildone  = 0;
  133.   my $linenum   = 0;
  134.   my $skiplines = 0;
  135.  
  136.   my $start = $Config{startperl};
  137.   $start = "#!perl" unless $start =~ /^#!.*perl/;
  138.  
  139.   my $in = IO::File->new("< $opts{in}") or die "Can't open $opts{in}: $!";
  140.   my @file = <$in>;
  141.   $in->close;
  142.  
  143.   foreach my $line ( @file ) {
  144.     $linenum++;
  145.     if ( $line =~ /^:endofperl\b/ ) {
  146.       if (!exists $opts{update}) {
  147.         warn "$opts{in} has already been converted to a batch file!\n";
  148.         return;
  149.       }
  150.       $taildone++;
  151.     }
  152.     if ( not $linedone and $line =~ /^#!.*perl/ ) {
  153.       if (exists $opts{update}) {
  154.         $skiplines = $linenum - 1;
  155.         $line .= "#line ".(1+$headlines)."\n";
  156.       } else {
  157.     $line .= "#line ".($linenum+$headlines)."\n";
  158.       }
  159.     $linedone++;
  160.     }
  161.     if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
  162.       $line = "";
  163.     }
  164.   }
  165.  
  166.   my $out = IO::File->new("> $opts{out}") or die "Can't open $opts{out}: $!";
  167.   print $out $head;
  168.   print $out $start, ( $opts{usewarnings} ? " -w" : "" ),
  169.              "\n#line ", ($headlines+1), "\n" unless $linedone;
  170.   print $out @file[$skiplines..$#file];
  171.   print $out $tail unless $taildone;
  172.   $out->close;
  173.  
  174.   return $opts{out};
  175. }
  176.  
  177.  
  178. sub split_like_shell {
  179.   # As it turns out, Windows command-parsing is very different from
  180.   # Unix command-parsing.  Double-quotes mean different things,
  181.   # backslashes don't necessarily mean escapes, and so on.  So we
  182.   # can't use Text::ParseWords::shellwords() to break a command string
  183.   # into words.  The algorithm below was bashed out by Randy and Ken
  184.   # (mostly Randy), and there are a lot of regression tests, so we
  185.   # should feel free to adjust if desired.
  186.   
  187.   (my $self, local $_) = @_;
  188.   
  189.   return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY');
  190.   
  191.   my @argv;
  192.   return @argv unless defined() && length();
  193.   
  194.   my $arg = '';
  195.   my( $i, $quote_mode ) = ( 0, 0 );
  196.   
  197.   while ( $i < length() ) {
  198.     
  199.     my $ch      = substr( $_, $i  , 1 );
  200.     my $next_ch = substr( $_, $i+1, 1 );
  201.     
  202.     if ( $ch eq '\\' && $next_ch eq '"' ) {
  203.       $arg .= '"';
  204.       $i++;
  205.     } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
  206.       $arg .= '\\';
  207.       $i++;
  208.     } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
  209.       $quote_mode = !$quote_mode;
  210.       $arg .= '"';
  211.       $i++;
  212.     } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
  213.           ( $i + 2 == length()  ||
  214.         substr( $_, $i + 2, 1 ) eq ' ' )
  215.         ) { # for cases like: a"" => [ 'a' ]
  216.       push( @argv, $arg );
  217.       $arg = '';
  218.       $i += 2;
  219.     } elsif ( $ch eq '"' ) {
  220.       $quote_mode = !$quote_mode;
  221.     } elsif ( $ch eq ' ' && !$quote_mode ) {
  222.       push( @argv, $arg ) if $arg;
  223.       $arg = '';
  224.       ++$i while substr( $_, $i + 1, 1 ) eq ' ';
  225.     } else {
  226.       $arg .= $ch;
  227.     }
  228.     
  229.     $i++;
  230.   }
  231.   
  232.   push( @argv, $arg ) if defined( $arg ) && length( $arg );
  233.   return @argv;
  234. }
  235.  
  236. 1;
  237.  
  238. __END__
  239.  
  240. =head1 NAME
  241.  
  242. Module::Build::Platform::Windows - Builder class for Windows platforms
  243.  
  244. =head1 DESCRIPTION
  245.  
  246. The sole purpose of this module is to inherit from
  247. C<Module::Build::Base> and override a few methods.  Please see
  248. L<Module::Build> for the docs.
  249.  
  250. =head1 AUTHOR
  251.  
  252. Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
  253.  
  254. =head1 SEE ALSO
  255.  
  256. perl(1), Module::Build(3)
  257.  
  258. =cut
  259.